VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Hooker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Const WH_JOURNALRECORD = &H0
Private Const WH_GETMESSAGE = &H3
Private Const WM_CANCELJOURNAL = &H4B

Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_SYSTEMKEYDOWN = &H104
Private Const WM_SYSTEMKEYUP = &H105

Private Type EVENTMSG
    wMsg As Long
    lParamL As Long
    lParamH As Long
    msgTime As Long
    hWndMsg As Long
End Type

Private EMSG As EVENTMSG

Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event SysKeyDown(KeyCode As Integer)
Public Event SysKeyUp(KeyCode As Integer)

Public Sub CreateHook()
    If hJouHook = 0 Then hJouHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JouHookProc, App.hInstance, 0)
    If hAppHook = 0 Then hAppHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf AppHookProc, App.hInstance, App.ThreadID)
End Sub

Public Property Get HookState() As Boolean
    If hAppHook = 0 Then
        HookState = False
    Else
        HookState = True
    End If
End Property

Public Sub RemoveHook()
    UnhookWindowsHookEx hAppHook: hAppHook = 0
    UnhookWindowsHookEx hJouHook: hJouHook = 0
End Sub

Private Sub Class_Initialize()
    lpHooker = ObjPtr(Me)
End Sub

Private Sub Class_Terminate()
    If hJouHook Or hAppHook Then RemoveHook
End Sub

Friend Sub CallEvent(ByVal lParam As Long)
    Dim i As Integer, j As Integer, K As Integer, s As String

    If lParam = WM_CANCELJOURNAL Then
        hJouHook = 0: CreateHook
        Exit Sub
    End If

    CopyMemory EMSG, ByVal lParam, Len(EMSG)

    Select Case EMSG.wMsg
        Case WM_KEYDOWN
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)

            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            RaiseEvent KeyDown(K, j)

            s = left$(s, 2) & right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_KEYUP
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            RaiseEvent KeyUp(K, j)

            s = left$(s, 2) & right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_MOUSEMOVE
            If GetAsyncKeyState(vbKeyLButton) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyRButton) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMButton) Then i = (i Or 4)
            If GetAsyncKeyState(vbKeyShift) Then j = (j Or 1)
            If GetAsyncKeyState(vbKeyControl) Then j = (j Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then j = (j Or 4)

            RaiseEvent MouseMove(i, j, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
            If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)

            RaiseEvent MouseDown(2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
            If GetAsyncKeyState(vbKeyShift) Then i = (i Or 1)
            If GetAsyncKeyState(vbKeyControl) Then i = (i Or 2)
            If GetAsyncKeyState(vbKeyMenu) Then i = (i Or 4)

            RaiseEvent MouseUp(2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamL), CSng(EMSG.lParamH))

        Case WM_SYSTEMKEYDOWN
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            If K <> vbKeyMenu Then RaiseEvent SysKeyDown(K)

            s = left$(s, 2) & right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case WM_SYSTEMKEYUP
            s = Hex(EMSG.lParamL)
            K = (EMSG.lParamL And &HFF)

            If K <> vbKeyMenu Then RaiseEvent SysKeyUp(K)

            s = left$(s, 2) & right$("00" & Hex(K), 2)
            EMSG.lParamL = CLng("&h" & s)
            CopyMemory ByVal lParam, EMSG, Len(EMSG)

        Case Else
    End Select
End Sub

